home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue27 / construc / BROKEN.PAS next >
Encoding:
Pascal/Delphi Source File  |  1997-09-29  |  14.8 KB  |  518 lines
  1. unit broken;
  2. {.$DEFINE REGISTER}
  3. {$I-}
  4. interface
  5. uses
  6.   Windows, WinINet, Classes;
  7.  
  8. const
  9.   BufSize = 256*1024;
  10.  
  11. type
  12.   TCheck = function(URL: ShortString; Depth: Integer): Integer of object;
  13.   TUpdate= procedure of object;
  14.  
  15.   TBrokenLink = class(TComponent)
  16.   private
  17.     Internet: HInternet;
  18.     HttpHandle: HInternet;
  19.     HttpRequest: HInternet;
  20.   private
  21.     Server: ShortString; { www.drbob42.com }
  22.     Buffer: String; { of BufSize }
  23.     ExecuteCGI: Boolean; { execute *.exe/*.asp? }
  24.   protected
  25.     FChecking: TStringList;
  26.     FChecked: TStringList;
  27.     FSuspect: TStringList; { non '.htm' files }
  28.     FBroken: TStringList;
  29.     FMailTo: TStringList;
  30.     FNews: TStringList;
  31.     FHTTP: TStringList;
  32.     FFTP: TStringList;
  33.   protected
  34.     FInterrupted: Boolean;
  35.     FOnUpdate: TUpdate;
  36.   protected
  37.     function CheckURLinFile(const URL,FileName: ShortString; Depth: Integer;
  38.                             HTTP: Boolean; CheckCallback: TCheck): Boolean;
  39.   protected
  40.     function LCheck(URL: ShortString; Depth: Integer): Integer;
  41.     function NCheck(URL: ShortString; Depth: Integer): Integer;
  42.   public
  43.     function LCheckURL(URL: ShortString; Depth: Integer): Boolean;
  44.     function NCheckURL(const URL: ShortString; CGI: Boolean; Depth: Integer): Boolean;
  45.   public
  46.     constructor Create(AOwner: TComponent); override;
  47.     destructor Destroy; override;
  48.   published
  49.     property Checking: TStringList read FChecking;
  50.     property Checked:  TStringList read FChecked;
  51.     property Suspect:  TStringList read FSuspect;
  52.     property Broken:   TStringList read FBroken;
  53.     property MailTo:   TStringList read FMailTo;
  54.     property News:     TStringList read FNews;
  55.     property HTTP:     TStringList read FHTTP;
  56.     property FTP:      TStringList read FFTP;
  57.   published
  58.     property Interrupted: Boolean read FInterrupted write FInterrupted;
  59.     property OnUpdate: TUpdate read FOnUpdate write FOnUpdate;
  60.   end;
  61.  
  62. {$IFDEF REGISTER}
  63.   procedure register;
  64. {$ENDIF}
  65.  
  66. implementation
  67. uses
  68.   SysUtils;
  69.  
  70. constructor TBrokenLink.Create(AOwner: TComponent);
  71. begin
  72.   inherited Create(AOwner);
  73.   FChecking := TStringList.Create;
  74.   FChecked := TStringList.Create;
  75.   FChecked.Sorted := True;
  76.   FSuspect := TStringList.Create;
  77.   FSuspect.Sorted := True;
  78.   FBroken := TStringList.Create;
  79.   FBroken.Sorted := True;
  80.   FMailTo := TStringList.Create;
  81.   FMailTo.Sorted := True;
  82.   FNews := TStringList.Create;
  83.   FNews.Sorted := True;
  84.   FHTTP := TStringList.Create;
  85.   FHTTP.Sorted := True;
  86.   FFTP := TStringList.Create;
  87.   FFTP.Sorted := True;
  88.   SetLength(Buffer,BufSize);
  89. end;
  90.  
  91. destructor TBrokenLink.Destroy;
  92. begin
  93.   Buffer := '';
  94.   FChecking.Free;
  95.   FChecked.Free;
  96.   FSuspect.Free;
  97.   FBroken.Free;
  98.   FMailTo.Free;
  99.   FNews.Free;
  100.   FHTTP.Free;
  101.   FFTP.Free;
  102.   inherited Destroy
  103. end;
  104.  
  105. function TBrokenLink.CheckURLinFile(const URL,FileName: ShortString; Depth: Integer;
  106.                                     HTTP: Boolean; CheckCallback: TCheck): Boolean;
  107. var
  108.   f: System.Text;
  109.   OldURL,NewURL: ShortString;
  110.   Upper,Str: String;
  111.   i: Integer;
  112. begin
  113. {$IFDEF DEBUG}
  114.   writeln('CheckURLinFile ',FileName);
  115. {$ENDIF}
  116.   System.Assign(f,FileName);
  117.   Reset(f);
  118.   Result := IOResult = 0;
  119.   if Result then
  120.   begin
  121.     if HTTP then readln(f,OldURL)
  122.             else OldURL := FileName;
  123.     while not eof(f) do
  124.     begin
  125.       readln(f,Str);
  126.       SetLength(Upper,Length(Str));
  127.       Upper := UpperCase(Str);
  128.       while Pos('<A HREF="',Upper) > 0 do
  129.       begin
  130.         Delete(Str,1,Pos('<A HREF="',Upper)+8);
  131.         Delete(Upper,1,Pos('<A HREF="',Upper)+8);
  132.         while (Length(Upper) > 0) and (Upper[1] = ' ') do Delete(Upper,1,1);
  133.         while (Length(Str) > 0) and (Str[1] = ' ') do Delete(Str,1,1);
  134.         if (Pos('#',Upper) <> 1) and
  135.            (Pos('MAILTO:',Upper) <> 1) and
  136.            (Pos('NEWS:',Upper) <> 1) and
  137.            (Pos('FTP://',Upper) <> 1)  then { skip mailto/news/ftp }
  138.         begin
  139.           if Pos('FILE:///',Upper) = 1 then
  140.           begin
  141.             Delete(Str,1,8);
  142.             Delete(Upper,1,8)
  143.           end;
  144.           if Pos('#',Upper) in [1..Pos('"',Upper)] then Upper[Pos('#',Upper)] := '"';
  145.           if Pos('#',Str) in [1..Pos('"',Str)] then Str[Pos('#',Str)] := '"';
  146.           if not ((Pos('://',Upper) in [1..Pos('"',Upper)]) or
  147.                   (Pos(':\',Upper) = 2) or (Upper[1] = '/')) then
  148.             Upper := URL + Upper; { path in front }
  149.           if not ((Pos('://',Str) in [1..Pos('"',Str)]) or
  150.                   (Pos(':\',Str) = 2) or (Str[1] = '/')) then
  151.             Str := URL + Str; { path in front }
  152.           while Pos('../',Upper) in [1..Pos('"',Upper)] do
  153.           begin
  154.             i := Pos('../',Upper);
  155.             Delete(Upper,i,3);
  156.             repeat
  157.               Dec(i);
  158.               Delete(Upper,i,1)
  159.             until Upper[i-1] = '/'
  160.           end;
  161.           while Pos('../',Str) in [1..Pos('"',Str)] do
  162.           begin
  163.             i := Pos('../',Str);
  164.             Delete(Str,i,3);
  165.             repeat
  166.               Dec(i);
  167.               Delete(Str,i,1)
  168.             until Str[i-1] = '/'
  169.           end;
  170.           while Pos('./',Upper) in [1..Pos('"',Upper)] do
  171.           begin
  172.             i := Pos('./',Upper);
  173.             Delete(Upper,i,2);
  174.             repeat
  175.               Dec(i);
  176.               Delete(Upper,i,1)
  177.             until Upper[i-1] = '/'
  178.           end;
  179.           while Pos('./',Str) in [1..Pos('"',Str)] do
  180.           begin
  181.             i := Pos('./',Str);
  182.             Delete(Str,i,2);
  183.             repeat
  184.               Dec(i);
  185.               Delete(Str,i,1)
  186.             until Str[i-1] = '/'
  187.           end;
  188.           NewURL := Copy(Str,1,Pos('"',Str)-1);
  189.           if (FChecking.IndexOf(NewURL) < 0) then
  190.           begin
  191.             if (not FChecked.Find(NewURL,i)) and
  192.                (not FHTTP.Find(NewURL,i)) and
  193.                (not FSuspect.Find(IntToStr(-i)+': '+OldURL+' => '+NewURL,i)) and
  194.                (not FBroken.Find(IntToStr(-i)+': '+OldURL+' => '+NewURL,i)) then
  195.             if (Pos('HTTP://',Upper) = 1) and not HTTP then
  196.             begin
  197.             {$IFDEF DEBUG}
  198.               writeln('external: ',NewURL);
  199.             {$ENDIF}
  200.               FHTTP.Add(NewURL)
  201.             end
  202.             else
  203.             if not FInterrupted then
  204.             if ExecuteCGI or (Pos('?',Upper) = 0) then
  205.             begin
  206.               i := CheckCallback(NewURL,Depth-1);
  207.               if i <= 0 then
  208.               begin
  209.                 if Pos('.htm',NewURL) > 0 then
  210.                 begin
  211.                 {$IFDEF DEBUG}
  212.                   writeln('broken: ',IntToStr(-i)+': '+OldURL+' => '+NewURL);
  213.                 {$ENDIF}
  214.                   FBroken.Add(IntToStr(-i)+': '+OldURL+' => '+NewURL)
  215.                 end
  216.                 else
  217.                 begin
  218.                 {$IFDEF DEBUG}
  219.                   writeln('suspect: ',IntToStr(-i)+': '+OldURL+' => '+NewURL);
  220.                 {$ENDIF}
  221.                   FSuspect.Add(IntToStr(-i)+': '+OldURL+' => '+NewURL)
  222.                 end
  223.               end
  224.               else
  225.               begin
  226.                 if (not HTTP) or (Pos(Server,NewURL) > 0) then
  227.                 begin
  228.                 {$IFDEF DEBUG}
  229.                   writeln('checked: ',NewURL);
  230.                 {$ENDIF}
  231.                   FChecked.Add(NewURL)
  232.                 end
  233.                 else
  234.                 begin
  235.                 {$IFDEF DEBUG}
  236.                   writeln('external: ',NewURL);
  237.                 {$ENDIF}
  238.                   FHTTP.Add(NewURL)
  239.                 end
  240.               end
  241.             end
  242.           end
  243.         end
  244.         else
  245.         begin
  246.           NewURL := Copy(Str,1,Pos('"',Str)-1);
  247.           if Pos('MAILTO:',Upper) = 1 then
  248.           begin
  249.           {$IFDEF DEBUG}
  250.             writeln('mailto: ',NewURL);
  251.           {$ENDIF}
  252.             if not FMailTo.Find(NewURL,i) then FMailTo.Add(NewURL)
  253.           end;
  254.           if Pos('NEWS://',Upper) = 1 then
  255.           begin
  256.           {$IFDEF DEBUG}
  257.             writeln('news: ',NewURL);
  258.           {$ENDIF}
  259.             if not FNews.Find(NewURL,i) then FNews.Add(NewURL)
  260.           end;
  261.           if Pos('FTP://',Upper) = 1 then
  262.           begin
  263.           {$IFDEF DEBUG}
  264.             writeln('ftp: ',NewURL);
  265.           {$ENDIF}
  266.             if not FFTP.Find(NewURL,i) then FFTP.Add(NewURL)
  267.           end
  268.         end;
  269.         if Assigned(FOnUpdate) then OnUpdate
  270.       end
  271.     end;
  272.     System.Close(f);
  273.     if HTTP then System.Erase(f);
  274.     if IOResult <> 0 then { skip }
  275.   end
  276. end {CheckURLinFile};
  277.  
  278.  
  279. function TBrokenLink.LCheck(URL: ShortString; Depth: Integer): Integer;
  280. var
  281.   Path: ShortString;
  282.   SRec: TSearchRec;
  283. begin
  284. {$IFDEF DEBUG}
  285.   writeln('checking: ',URL);
  286. {$ENDIF}
  287.   FChecking.Add(URL);
  288.   if Assigned(FOnUpdate) then OnUpdate;
  289.   if FindFirst(URL,faArchive,SRec) = 0 then
  290.     Result := SRec.Size
  291.   else
  292.     Result := -1;
  293.   FindClose(SRec);
  294.   Path := URL;
  295.   repeat
  296.     Delete(Path,Length(Path),1)
  297.   until (Length(Path) = 0) or (Path[Length(Path)] = '/') or (Path[Length(Path)] = '\');
  298.   if (Result > 0) and not FInterrupted then
  299.     CheckURLinFile(Path,URL,Depth-1,False,LCheck);
  300.   FChecking.Delete(Pred(FChecking.Count));
  301.   if Assigned(FOnUpdate) then OnUpdate
  302. end {LCheck};
  303.  
  304. function TBrokenLink.LCheckURL(URL: ShortString; Depth: Integer): Boolean;
  305. begin
  306.   FInterrupted := False;
  307.   FChecking.Clear;
  308.   FChecked.Clear;
  309.   FSuspect.Clear;
  310.   FBroken.Clear;
  311.   FMailTo.Clear;
  312.   FNews.Clear;
  313.   FHTTP.Clear;
  314.   FFTP.Clear;
  315.   if Pos('file:///',URL) = 1 then Delete(URL,1,8);
  316.   Depth := LCheck(URL,Depth);
  317.   Result := Depth > 0;
  318.   if Result then
  319.   begin
  320.   {$IFDEF DEBUG}
  321.     writeln('checked: ',URL);
  322.   {$ENDIF}
  323.     FChecked.Add(URL)
  324.   end
  325.   else
  326.   begin
  327.     if Pos('.htm',URL) > 0 then
  328.     begin
  329.     {$IFDEF DEBUG}
  330.       writeln('broken: ',IntToStr(Depth)+': -> '+URL);
  331.     {$ENDIF}
  332.       FBroken.Add(IntToStr(Depth)+': -> '+URL)
  333.     end
  334.     else
  335.     begin
  336.     {$IFDEF DEBUG}
  337.       writeln('suspect: ',IntToStr(Depth)+': -> '+URL);
  338.     {$ENDIF}
  339.       FSuspect.Add(IntToStr(Depth)+': -> '+URL)
  340.     end
  341.   end;
  342.   if Assigned(FOnUpdate) then OnUpdate
  343. end {LCheckURL};
  344.  
  345.  
  346. function TBrokenLink.NCheck(URL: ShortString; Depth: Integer): Integer;
  347. const
  348.   Name = 'c:\tmp\dump.%d';
  349.   Ext: Word = 0;
  350. var
  351.   Index,Size: DWord;
  352.   f: File;
  353. begin
  354.   if URL[Length(URL)] = '/' then Delete(URL,Length(URL),1); { skip last '/' }
  355. {$IFDEF DEBUG}
  356.   writeln('checking: ',URL);
  357. {$ENDIF}
  358.   FChecking.Add(URL);
  359.   if Assigned(FOnUpdate) then OnUpdate;
  360.   URL[Length(URL)+1] := #0; // PChar
  361. {$IFDEF DEBUG}
  362.   writeln('HttpOpenRequest');
  363. {$ENDIF}
  364.   HttpRequest := HttpOpenRequest(HttpHandle, nil, @URL[1],
  365.                                  nil, nil, nil,
  366.                                  INTERNET_FLAG_RELOAD OR INTERNET_FLAG_EXISTING_CONNECT,
  367.                                  0);
  368.   if HttpRequest <> nil then
  369.   begin
  370.   {$IFDEF DEBUG}
  371.     writeln('HttpSendRequest');
  372.   {$ENDIF}
  373.     if HttpSendRequest(HttpRequest, nil, 0, nil, 0) then
  374.     begin
  375.       Index := 0;
  376.     { FillChar(Buffer[1],BufSize,#0); }
  377.       Size := BufSize;
  378.       {$IFDEF DEBUG}
  379.         writeln('HttpQueryInfo');
  380.       {$ENDIF}
  381.       HttpQueryInfo(HttpRequest,1,@Buffer[1],Size,Index)
  382.     end;
  383.     FillChar(Buffer[1],BufSize,#0);
  384.     Size := BufSize;
  385.     {$IFDEF DEBUG}
  386.       writeln('InternetReadFile');
  387.     {$ENDIF}
  388.     if ((Pos('.HTM',UpperCase(URL)) = 0) and (Pos('.ASP',UpperCase(URL)) = 0))  or
  389.        (Pos(Server,URL) = 0) or
  390.        (Depth <= 0) then Size := 512;
  391.     if InternetReadFile(HttpRequest,@Buffer[1],Size,Size) then
  392.     begin
  393.       if Pos('HTTP/1.0 ',Buffer) in [1..255] then { broken }
  394.       try
  395.         Result := - StrToInt(Copy(Buffer,Pos('HTTP/1.0 ',Buffer)+9,3));
  396.       except
  397.         Result := -1
  398.       end
  399.       else Result := Size;
  400.       Inc(Ext);
  401.       System.Assign(f,Format(Name,[Ext]));
  402.       Rewrite(f,1);
  403.       URL := URL+#13+#10;
  404.       BlockWrite(f,URL[1],Length(URL)); { HTTP: first line = old URL }
  405.       BlockWrite(f,Buffer[1],Size);
  406.       System.Close(f);
  407.       repeat
  408.         Delete(URL,Length(URL),1)
  409.       until (Length(URL) = 0) or (URL[Length(URL)] = '/') or (URL[Length(URL)] = '\');
  410.       if (Depth > 0) and (Pos(Server,URL) > 0) and not FInterrupted then
  411.         CheckURLinFile(URL,Format(Name,[Ext]),Depth-1,True,NCheck)
  412.       else { cleanup }
  413.         Erase(f)
  414.     end
  415.     else Result := -2;
  416.     {$IFDEF DEBUG}
  417.       writeln('InternetCloseHandle');
  418.     {$ENDIF}
  419.     InternetCloseHandle(HttpRequest)
  420.   end
  421.   else Result := -4;
  422.   FChecking.Delete(Pred(FChecking.Count));
  423.   if Assigned(FOnUpdate) then OnUpdate
  424. end {NRequest};
  425.  
  426. function TBrokenLink.NCheckURL(const URL: ShortString; CGI: Boolean; Depth: Integer): Boolean;
  427. begin
  428.   Result := True;
  429.   ExecuteCGI := CGI;
  430.   FInterrupted := False;
  431.   FChecking.Clear;
  432.   FChecked.Clear;
  433.   FSuspect.Clear;
  434.   FBroken.Clear;
  435.   FMailTo.Clear;
  436.   FNews.Clear;
  437.   FHTTP.Clear;
  438.   FFTP.Clear;
  439.   Server := URL;
  440.   mkdir('C:\tmp');
  441.   if IOResult <> 0 then { skip };
  442.   if Pos(':',Server) > 0 then
  443.   begin
  444.     Delete(Server,1,Pos(':',Server));
  445.     repeat
  446.       Delete(Server,1,1)
  447.     until Server[1] <> '/'
  448.   end;
  449.   Delete(Server,Pos('/',Server),255);
  450.   Server[Length(Server)+1] := #0;
  451.   {$IFDEF DEBUG}
  452.     writeln('InternetOpen');
  453.   {$ENDIF}
  454.   {$IFDEF VER100}
  455.     Internet := InternetOpen('DrBob', LOCAL_INTERNET_ACCESS, nil, nil, 0);
  456.   {$ELSE}
  457.     Internet := InternetOpen('DrBob', LOCAL_INTERNET_ACCESS, @Server[1], 80, 0);
  458.   {$ENDIF}
  459.   if Internet <> nil then
  460.   try
  461.   {$IFDEF DEBUG}
  462.     writeln('InternetConnect');
  463.   {$ENDIF}
  464.     HttpHandle := InternetConnect(Internet, @Server[1],
  465.                                   INTERNET_DEFAULT_HTTP_PORT, nil, nil,
  466.                                   Internet_Service_Http, 0, 0);
  467.     if HttpHandle <> nil then
  468.     try
  469.       Depth := NCheck(URL,Depth);
  470.       Result := Depth > 0;
  471.       if Result then
  472.       begin
  473.       {$IFDEF DEBUG}
  474.         writeln('external: ',URL);
  475.       {$ENDIF}
  476.         FChecked.Add(URL)
  477.       end
  478.       else
  479.       begin
  480.         if Pos('.htm',URL) > 0 then
  481.         begin
  482.         {$IFDEF DEBUG}
  483.           writeln('broken: ',IntToStr(-Depth)+': '+Server+' -> '+URL);
  484.         {$ENDIF}
  485.           FBroken.Add(IntToStr(-Depth)+': '+Server+' -> '+URL)
  486.         end
  487.         else
  488.         begin
  489.         {$IFDEF DEBUG}
  490.           writeln('suspect: ',IntToStr(-Depth)+': '+Server+' -> '+URL);
  491.         {$ENDIF}
  492.           FSuspect.Add(IntToStr(-Depth)+': '+Server+' -> '+URL)
  493.         end
  494.       end;
  495.       if Assigned(FOnUpdate) then OnUpdate;
  496.     finally
  497.     {$IFDEF DEBUG}
  498.       writeln('InternetCloseHandle');
  499.     {$ENDIF}
  500.       InternetCloseHandle(HttpHandle)
  501.     end;
  502.   finally
  503.   {$IFDEF DEBUG}
  504.     writeln('InternetCloseHandle');
  505.   {$ENDIF}
  506.     InternetCloseHandle(Internet)
  507.   end
  508. end {CheckURL};
  509.  
  510. {$IFDEF REGISTER}
  511. procedure register;
  512. begin
  513.   RegisterComponents('Dr.Bob',[TBrokenLink])
  514. end;
  515. {$ENDIF}
  516.  
  517. end.
  518.